home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.3 / ice-9 / r4rs.scm.z / r4rs.scm
Encoding:
Text File  |  1999-04-16  |  4.6 KB  |  146 lines
  1. ;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
  2. ;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
  3.  
  4. ;;;;     Copyright (C) 1996, 1997, 1998 Free Software Foundation, Inc.
  5. ;;;; 
  6. ;;;; This program is free software; you can redistribute it and/or modify
  7. ;;;; it under the terms of the GNU General Public License as published by
  8. ;;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;;; any later version.
  10. ;;;; 
  11. ;;;; This program is distributed in the hope that it will be useful,
  12. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;;; GNU General Public License for more details.
  15. ;;;; 
  16. ;;;; You should have received a copy of the GNU General Public License
  17. ;;;; along with this software; see the file COPYING.  If not, write to
  18. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  19. ;;;; Boston, MA 02111-1307 USA
  20.  
  21.  
  22. ;;;; apply and call-with-current-continuation
  23.  
  24. ;;; We want these to be tail-recursive, so instead of using primitive
  25. ;;; procedures, we define them as closures in terms of the primitive
  26. ;;; macros @apply and @call-with-current-continuation.
  27. (set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
  28. (set-procedure-property! apply 'name 'apply)
  29. (define (call-with-current-continuation proc)
  30.   (@call-with-current-continuation proc))
  31.  
  32.  
  33. ;;;; Basic Port Code
  34.  
  35. ;;; Specifically, the parts of the low-level port code that are written in 
  36. ;;; Scheme rather than C.
  37. ;;;
  38. ;;; WARNING: the parts of this interface that refer to file ports
  39. ;;; are going away.   It would be gone already except that it is used
  40. ;;; "internally" in a few places.
  41.  
  42.  
  43. ;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the
  44. ;;; proper mode to open files in.
  45. ;;;
  46. ;;; If we want to support systems that do CRLF->LF translation, like
  47. ;;; Windows, then we should have a symbol in scmconfig.h made visible
  48. ;;; to the Scheme level that we can test here, and autoconf magic to
  49. ;;; #define it when appropriate.  Windows will probably just have a
  50. ;;; hand-generated scmconfig.h file.
  51. (define OPEN_READ "r")
  52. (define OPEN_WRITE "w")
  53. (define OPEN_BOTH "r+")
  54.  
  55. (define *null-device* "/dev/null")
  56.  
  57. (define (open-input-file str)
  58.   (open-file str OPEN_READ))
  59.  
  60. (define (open-output-file str)
  61.   (open-file str OPEN_WRITE))
  62.  
  63. (define (open-io-file str) (open-file str OPEN_BOTH))
  64. (define close-input-port close-port)
  65. (define close-output-port close-port)
  66. (define close-io-port close-port)
  67.  
  68. (define (call-with-input-file str proc)
  69.   (let* ((file (open-input-file str))
  70.      (ans (proc file)))
  71.     (close-input-port file)
  72.     ans))
  73.  
  74. (define (call-with-output-file str proc)
  75.   (let* ((file (open-output-file str))
  76.      (ans (proc file)))
  77.     (close-output-port file)
  78.     ans))
  79.  
  80. (define (with-input-from-port port thunk)
  81.   (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
  82.     (dynamic-wind swaports thunk swaports)))
  83.  
  84. (define (with-output-to-port port thunk)
  85.   (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
  86.     (dynamic-wind swaports thunk swaports)))
  87.  
  88. (define (with-error-to-port port thunk)
  89.   (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
  90.     (dynamic-wind swaports thunk swaports)))
  91.  
  92. (define (with-input-from-file file thunk)
  93.   (let* ((nport (open-input-file file))
  94.      (ans (with-input-from-port nport thunk)))
  95.     (close-port nport)
  96.     ans))
  97.  
  98. (define (with-output-to-file file thunk)
  99.   (let* ((nport (open-output-file file))
  100.      (ans (with-output-to-port nport thunk)))
  101.     (close-port nport)
  102.     ans))
  103.  
  104. (define (with-error-to-file file thunk)
  105.   (let* ((nport (open-output-file file))
  106.      (ans (with-error-to-port nport thunk)))
  107.     (close-port nport)
  108.     ans))
  109.  
  110. (define (with-input-from-string string thunk)
  111.   (call-with-input-string string
  112.    (lambda (p) (with-input-from-port p thunk))))
  113.  
  114. (define (with-output-to-string thunk)
  115.   (call-with-output-string
  116.    (lambda (p) (with-output-to-port p thunk))))
  117.  
  118. (define (with-error-to-string thunk)
  119.   (call-with-output-string
  120.    (lambda (p) (with-error-to-port p thunk))))
  121.  
  122. (define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
  123.  
  124.  
  125. ;;;; Loading
  126.  
  127. (if (not (defined? '%load-verbosely))
  128.     (define %load-verbosely #f))
  129. (define (assert-load-verbosity v) (set! %load-verbosely v))
  130.  
  131. (define (%load-announce file)
  132.   (if %load-verbosely
  133.       (with-output-to-port (current-error-port)
  134.     (lambda ()
  135.       (display ";;; ")
  136.       (display "loading ")
  137.       (display file)
  138.       (newline)
  139.       (force-output)))))
  140.  
  141. (set! %load-hook %load-announce)
  142.  
  143. (define (load name)
  144.   (start-stack 'load-stack
  145.            (primitive-load name)))
  146.